COMMENT ⊗   VALID 00005 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	{$NOMAIN	Parser auxilliary routines }
C00004 00003	(* routine to show where error occurred: errprnt *)
C00006 00004	(* auxiliary expression mungers: relExpr & evalOrder, ppFlush *)
C00015 00005	(* aux routines for dimension checking: matchdim, getdim, checkdim *)
C00022 ENDMK
C⊗;
{$NOMAIN	Parser auxilliary routines }

%include palhdr.pas;

{ Externally defined routines from elsewhere: }

	(* From ALLOC *)
procedure relVector(v: vectorp);				external;
procedure relTrans(t: transp);					external;
function newNode: nodep;					external;
procedure relNode(n: nodep);					external;
procedure relStrng(n: strngp);					external;

	(* Display-related Routines *)
procedure ppLine; 						external;
procedure ppOutNow; 						external;
procedure ppChar(ch: ascii); 					external;
procedure pp5(ch: c5str; length: integer); 			external;
procedure pp10(ch: cstring; length: integer); 			external;
procedure pp10L(ch: cstring; length: integer);			external;
procedure pp20(ch: c20str; length: integer); 			external;
procedure pp20L(ch: c20str; length: integer); 			external;
procedure ppInt(i: integer); 					external;
procedure ppStrng(length: integer; s: strngp); 			external;

(* routine to show where error occurred: errprnt *)

procedure errprnt; external;
procedure errprnt;
 var i,j: integer; s: strngp;
 begin
 errcount := errcount + 1;  (* keep track of how many errors we've reported *)
 if (not shownline) and ((filedepth > 0) or (macrodepth > 0)) then
  begin						(* tell where error occured *)
  ppLine; ppChar('p'); ppInt(curpage); pp5(', l  ',3); ppInt(curline);
  if macrodepth > 0 then
   begin
   pp20(' while expanding mac',20); pp5('ro:  ',4);
   with curmacstack[macrodepth]↑.name↑ do
    ppstrng(length,name);
   end;
  ppLine;
  (* if reading a file then ..... *)
  for i := 1 to maxchar do ppChar(line[i]);	(* show line *)
  shownline := true;
  end;
 ppLine;
 for i := 1 to curchar-1 do ppChar(' ');	(* show where in line *)
 ppChar('↑'); ppLine;
 end;

(* auxiliary expression mungers: relExpr & evalOrder, ppFlush *)

procedure relExpr(n: nodep); external;
procedure relExpr;
 var b: boolean; st,stp: strngp;
 begin
 b := true;
 if n = nil then b := false
  else
   with n↑ do
    case ntype of
exprnode: begin
	  relExpr(arg1);
	  relExpr(arg2);
	  relExpr(arg3);
	  end;
leafnode: case ltype of
  vectype:   if v↑.refcnt <= 1 then relVector(v)
	      else v↑.refcnt := v↑.refcnt - 1;
  transtype: if t↑.refcnt <= 1 then relTrans(t)
	      else t↑.refcnt := t↑.refcnt - 1;
  strngtype: if (length <> 2) or (str↑.ch[1] <> chr(15B)) or
		(str↑.ch[2] <> chr(12B)) then
	       begin
	       st := str;
	       while st <> nil do
		begin stp := st↑.next; relStrng(st); st := stp end;
	       end
	      else b := false;
  otherwise  {do nothing};
	   end;
listnode: begin
	  relExpr(lval);
	  relExpr(next);
	  end;
ffnode:	  begin
	  if pdef then relNode(ff)
	   else relExpr(ff);
	  end;
forcenode:begin
	  relExpr(fval);
	  relExpr(fvec);
	  relExpr(fframe);
	  end;
arraydefnode: relExpr(bounds);
bnddefnode:begin
	  relExpr(lower);
	  relExpr(upper);
	  relExpr(next);
	  end;
otherwise {do nothing};
    end;
 if b then relNode(n);
 end;

function evalOrder(what,last: nodep; pcons: boolean): nodep; external;
function evalOrder;
 var vp: varidefp; n: nodep; tbits: integer;
 begin
 if what <> nil then
   with what↑ do
    case ntype of
exprnode:
     if (op < ioop) or (op = adcop) or (op = dacop) then
       begin				(* regular ops are easy to handle *)
       next := last;
       last := evalOrder(arg1,what,false); (* all ops have at least one arg *)
       if arg2 <> nil then last := evalOrder(arg2,last,false);
       if arg3 <> nil then last := evalOrder(arg3,last,false);
       end
      else if (op = grinchop) then last := evalOrder(arg1,last,true)
      else if op < specop then			(* query or inscalar *)
       begin
       what↑.next := last;
       if op = inscalarop then last := what	(* inscalar has no args *)
	else if arg2 = nil then last := what	(* query has no print list *)
	else last := evalOrder(arg2,what,false); (* handle query's print list *)
       end
      else if op = arefop then
       begin
       arg1↑.next := last;
       last := evalOrder(arg2,arg1,true);	(* need to push constants too *)
       end
      else if op = callop then
       begin
       what↑.next := last;
       last := what;
       if arg2 <> nil then
	 begin
	 with arg1↑.vari↑ do
	  if p <> nil then vp := p↑.paramlist else vp := nil;
	 n := arg2;
	 while n <> nil do
	  begin					(* evaluate parameters *)
	  if vp <> nil then
	    begin
	    tbits := vp↑.tbits;
	    vp := vp↑.next;
	    end
	   else tbits := 0;
	  with n↑.lval↑ do
	   begin
	   if (tbits = 4) then				(* call by reference *)
	    if ((ntype = exprnode) and (op <> arefop)) or	(* expression *)
	       ((ntype = leafnode) and (ltype <> varitype))     (* constant *)
	     then tbits := 0;			(* change to call by value *)
	   if tbits = 0 then last := evalOrder(n↑.lval,last,false)
	    else if (tbits = 4) and (ntype = exprnode) then
	     last := evalOrder(arg2,last,true);		(* push subscripts *)
	   end;
	  n := n↑.next;
	  end
	 end
       end
      else if op = badop then  (* stick default value node so it goes on stack *)
       begin
       arg2↑.next := last;
       last := arg2;
       end;
listnode:
     begin
     last := evalOrder(lval,last,pcons);  (* set up this list element's value *)
     if next <> nil then
       last := evalOrder(next,last,pcons);	(* now move down the list *)
     end;
bnddefnode:
     begin
     last := evalOrder(lower,last,false);  (* set up this subscript's values *)
     last := evalOrder(upper,last,false);
     if next <> nil then
       last := evalOrder(next,last,false);	(* now move down the list *)
     end;
leafnode:
     if pcons or (ltype = varitype) then
       begin	(* get variable's value or if asked push constants *)
       next := last;
       last := what;
       end;
durnode:
     last := evalOrder(durval,last,false);	(* evaluate duration value *)
deprnode,
apprnode,
destnode:
     begin
     last := evalOrder(loc,last,false);		(* evaluate location *)
     if code <> nil then
      if code↑.stype = signaltype then
       if code↑.event↑.ntype <> leafnode then
	last := evalOrder(code↑.event↑.arg2,last,true);
     end;
viaptnode:
     begin
     last := evalOrder(via,last,false);		(* evaluate location *)
     if duration <> nil then
      last := evalOrder(duration,last,false);	(* evaluate duration *)
     if velocity <> nil then
      last := evalOrder(velocity,last,false);	(* evaluate velocity *)
     if vcode <> nil then
      if vcode↑.stype = signaltype then
       if vcode↑.event↑.ntype <> leafnode then
	last := evalOrder(vcode↑.event↑.arg2,last,true);
     end;
forcenode:
     begin
     last := evalOrder(fval,last,false);	(* evaluate force value *)
     end;
otherwise {do nothing};
    end;
 evalOrder := last;
 end;

procedure ppFlush; external;
procedure ppFlush;
 begin pp20(' Will flush statemen',20); ppChar('t'); end;

(* aux routines for dimension checking: matchdim, getdim, checkdim *)

function matchdim(d1,d2: nodep; exactp: boolean): boolean; external;
function matchdim;
 var b: boolean;
 begin
 with d1↑ do
  b := (time = d2↑.time) and (distance = d2↑.distance) and
	(angle = d2↑.angle) and (dforce = d2↑.dforce);
 if not (b or exactp) then
   begin	(* see if we can coerce d1 or d2, i.e. one is dimensionless *)
   with d1↑ do
    if (time = 0) and (distance = 0) and (angle = 0) and (dforce = 0) then
     b := true;
   if not b then		(* see if d2 is dimensionless *)
    with d2↑ do
     if (time = 0) and (distance = 0) and (angle = 0) and (dforce = 0) then
      b := true;
   end;
 matchdim := b;
 end;

function getdim(n: nodep; var d: nodep): nodep; external;
function getdim;
 var vdim: varidefp; d1: nodep;

 procedure dimCopy(dp: nodep);
  begin
  with d↑ do
   begin
   time := dp↑.time;
   distance := dp↑.distance;
   angle := dp↑.angle;
   dforce := dp↑.dforce;
   end
  end;

 procedure dimMod(d1,d2: nodep; i: real);
  begin
  with d↑ do
   begin
   time := d1↑.time + round(i * d2↑.time);
   distance := d1↑.distance + round(i * d2↑.distance);
   angle := d1↑.angle + round(i * d2↑.angle);
   dforce := d1↑.dforce + round(i * d2↑.dforce);
   end
  end;

 begin
 if d = nil then
  begin
  d := newNode;	(* need to make up a new dimension node to hold result *)
  d↑.ntype := dimnode;
  end;
 if n = nil then dimCopy(nodim↑.dim)
  else
   with n↑ do
    if (ntype = leafnode) or (ntype = procdefnode) then
      begin
      if ntype = procdefnode then vdim := pname
       else if ltype = varitype then vdim := vari
       else if ltype = pconstype then vdim := cname
       else vdim := nil;
      if vdim <> nil then	(* see if there's an associated dimension *)
       with vdim↑ do
	if dtype <> nil then vdim := dtype	(* yes - use it *)
	 else
	  if (vtype = transtype) or (vtype = frametype) then vdim := distancedim
	   else if vtype = rottype then vdim := angledim else vdim := nil;
      if vdim <> nil then dimCopy(vdim↑.dim) else dimCopy(nodim↑.dim)
      end
     else			(* see what type of expression it is *)
      begin
      d1 := nil;
      if (op <= eqvop) or ((sinop <= op) and (op <= tanop)) or (op = sexpop) or
	 (op = logop) or (op = expop) or (op = unitvop) or (op = taxisop) or
	 (op = queryop) or (op = inscalarop) or (op = adcop) or (op = vmop) then
	  dimCopy(nodim↑.dim)
       else if op = timeop then dimCopy(timedim↑.dim)
       else if ((asinop <= op) and (op <= atan2op)) or (op = torientop) or
	 (op = vsaxwrop) then dimCopy(angledim↑.dim)
       else if (op = constrop) or (op = fmakeop) or (op = deproachop) or
	 (op = grinchop) then dimCopy(distancedim↑.dim)
       else if (op = tmakeop) or (op = tvmulop) or (op = ttmulop) then
	  d := getdim(arg2,d)
       else if (op = smulop) or (op = svmulop) or (op = vsmulop) or
	 (op = vdotop) or (op = crossvop) then
	  dimMod(getdim(arg1,d),getdim(arg2,d1),1.0)
       else if (op = sdivop) or (op = idivop) or (op = vsdivop) then
	  dimMod(getdim(arg1,d),getdim(arg2,d1),-1.0)
       else if (op = sqrtop) then dimMod(nodim↑.dim,getdim(arg1,d),0.5)
       else if (op = negop) then dimMod(nodim↑.dim,getdim(arg1,d),-1.0)
		   (* special - used by dimension statement *)
       else d := getdim(arg1,d); (* sadd,ssub,sneg,sabs,max,min,int,mod,vmagn,
				    tmagn,vmake,vadd,vsub,vneg,tpos,tvadd,tvsub,
				    tinvrt,ftof,aref,call,bad *)
    if d1 <> nil then relNode(d1);
    end;
 getdim := d;
 end;

procedure checkdim(n,d: nodep);	external; (* expr n should be of dimension d *) 
procedure checkdim;
 var dp: nodep;
 begin
 dp := nil;
 if not matchdim(getdim(n,dp),d,dimCheck) then	(* does dimension match ok? *)
  begin
  pp20L('Dimensions don''t mat',20); pp5('ch   ',2);
  errprnt;
  end;
 relNode(dp);
 end;